(defpackage :smart-tree
  (:use :cl)
  (:export :smart-tree-view))

(in-package :smart-tree)

(defclass smart-tree-view (new-tree:new-tree)
  ((first-time :initform t :accessor first-time)))

(defun mark-all-as-spaced (root)
  (d:funcall-on-tree (lambda (x) (setf (d:property x :spaced) t)) root))

(defun force-space-tree (diagram)
  (new-tree::space-tree diagram))

(defun fit-new-child-boxes (diagram parent)
  ;; (print `(fit ,(tv::childq parent)))
  (loop
     for last = nil then i
     for boxes on (d:child-boxes parent)
     for i = (first boxes)
     for next-spaced = (find-if (u:curry d:property (c) :spaced) boxes)
     unless (d:property i :spaced)
     do (cond
          (last
           (if (= (geom:y last) (- (geom:y parent) (geom:height parent) (d:vpadding diagram)))
              (setf (d:box-x i) (+ (geom:right last) (d:hpadding diagram))
                    (d:box-y i) (- (geom:y parent) (geom:height i) (d:vpadding diagram)))
              (setf (d:box-x i) (+ (geom:centerx parent) (d:hpadding diagram))
                    (d:box-y i) (- (geom:y parent) (geom:height i) (d:vpadding diagram)))))
          (next-spaced
           (if (and (= (geom:y next-spaced) (- (geom:y parent) (geom:height parent) (d:vpadding diagram)))
                    (<= (geom:x next-spaced) (+ (geom:right parent) (d:hpadding diagram))))
              (setf (d:box-x i) (- (geom:x next-spaced) (geom:width i) (d:hpadding diagram))
                    (d:box-y i) (- (geom:y parent) (geom:height i) (d:vpadding diagram)))
              (setf (d:box-x i) (- (geom:centerx parent) (geom:width i) (d:hpadding diagram))
                    (d:box-y i) (- (geom:y parent) (geom:height i) (d:vpadding diagram)))))
          (t
           ;; (print `(default))
           (setf (d:box-x i) (- (geom:centerx parent) (u:half (geom:width i)))
                 (d:box-y i) (- (geom:y parent) (geom:height i) (d:vpadding diagram)))))))

(defun collect-parents-for-fitting (root)
  (let (acc)
    (d:funcall-on-tree (lambda (node)
                         (when (not (d:property node :spaced))
                           (pushnew (if (d:multiparent-box-p node)
                                        (loop
                                           for i in (d:parent-boxes node)
                                           with y = (geom:y (first (d:parent-boxes node)))
                                           with ret = (first (d:parent-boxes node))
                                           when (< (geom:y i) y)
                                           do (setf y (geom:y i)
                                                    ret i)
                                           finally (return ret))
                                        (first (d:parent-boxes node)))
                                    acc)))
                       root
                       :only-boxes t)
    (sort acc (lambda (a b)
                (tree:descendant-p b a)))))

(defun make-space-for (diagram box)
  "if Box overlaps any other spaced boxes then they should be pushed out of the way."
  (let ((overlaps (d:collect-on-tree (lambda (b)
                                       (and (d:property b :spaced)
                                            (u:neq box b)
                                            (geom:overlap-p b box)))
                                     (d:root diagram)
                                     :only-boxes t)))
    (loop for b in overlaps do
         (cond ((tree:descendant-p b box)
                (setf (d:tree-y b) (- (geom:y box) (geom:height b) (d:vpadding diagram))))
               ((>= (geom:x box) (geom:x b))
                (unless (d:property b :origin)
                  (setf (d:property b :origin) (geom:pt-from b)))
                (setf (d:box-x b) (- (geom:x box) (geom:width b) (d:hpadding diagram))))
               (t
                (unless (d:property b :origin)
                  (setf (d:property b :origin) (geom:pt-from b)))
                (setf (d:box-x b) (+ (geom:right box) (d:hpadding diagram))))))))

(defun make-space-for-arrows (diagram box)
  )

(defun return-to-origin (tree)
  "Return all trees that have been moved back to their original
positions before attempting to make space. This lets boxes spring back
as the user adds and deletes text in input boxes."
  (d:funcall-on-tree (lambda (b)
                       (let ((old (d:property b :origin)))
                         (when old
                           (setf (d:box-x b) (geom:x old)
                                 (d:box-y b) (geom:y old)))))
                     tree
                     :only-boxes t))

(defmethod d:space-tree ((diagram smart-tree-view))
  (cond
    ((first-time diagram)
     (force-space-tree diagram))
    ((d:find-if-on-tree (lambda (n) (not (d:property n :spaced)))
                        (d:root diagram))
     (d:funcall-on-tree (lambda (x)
                          (new-tree::resize-box x diagram))
                        (d:root diagram)
                        :only-boxes t)
     (dolist (b (collect-parents-for-fitting (d:root diagram)))
       (fit-new-child-boxes diagram b))
     (d:funcall-on-tree (lambda (x)
                          (make-space-for diagram x))
                        (d:root diagram)
                        :only-boxes t)
     (mark-all-as-spaced (d:root diagram)))
    (t ;; do almost nuthing
     (d:funcall-on-tree (lambda (x)
                          (new-tree::resize-box x diagram))
                        (d:root diagram)
                        :only-boxes t)
     (return-to-origin (d:root diagram))
     (d:funcall-on-tree (lambda (x)
                          (make-space-for diagram x))
                        (d:root diagram)
                        :only-boxes t)
     nil)))

(defmethod d:update-diagram-view ((v smart-tree-view))
  (when (d:root v)
    (d:space-tree v)
    (when (first-time v)
      (d:center-root v)))
  (setf (first-time v) nil))

(defun test (tree from-id to)
  (gwee:with-gui (1024 768 :font "sans.ttf" :background (gwee:gray 255) :foreground (gwee:gray 0))
    (let ((v (make-instance 'smart-tree-view
                            :width 1024 :height 764
                            :parent gwee:*top-view*)))
      (setf (d:root v) tree)
      (d:update-diagram-view v)
      (setf (d:root v) (o::nsubstitute-node-by-id tree from-id to))
      ;;(print `(subst))
      (d:space-tree v))))

(defun test-1 ()
  (test [DIAGRAM:MULTI-ARGUMENT-BOX [DIAGRAM:ARGUMENT 9 [DIAGRAM:MULTI-ARGUMENT-BOX [DIAGRAM:ARGUMENT 'NIL [DIAGRAM:MULTI-ARGUMENT-BOX [DIAGRAM:ARGUMENT 'NIL [DIAGRAM:MULTI-ARGUMENT-BOX [DIAGRAM:ARGUMENT 4  :ID 200] [DIAGRAM:ARGUMENT '-  :ID 201] [DIAGRAM:ARGUMENT 9  :ID 202] :ID 203]  :ID 204] [DIAGRAM:ARGUMENT '-  :ID 205] [DIAGRAM:ARGUMENT 'NIL [DIAGRAM:MULTI-ARGUMENT-BOX [DIAGRAM:ARGUMENT 5  :ID 206] [DIAGRAM:ARGUMENT '-  :ID 207] [DIAGRAM:ARGUMENT 3  :ID 208] :ID 209]  :ID 210] :ID 211]  :ID 212] [DIAGRAM:ARGUMENT '-  :ID 213] [DIAGRAM:ARGUMENT 8  :ID 214] :ID 215]  :ID 216] :ID 217] 209 [m [a 5] [a 9]]))

(defun test-2 ()
  (let* ((tree [DIAGRAM:MULTI-ARGUMENT-BOX [DIAGRAM:ARGUMENT 4 [DIAGRAM:MULTI-ARGUMENT-BOX [DIAGRAM:ARGUMENT 'NIL [DIAGRAM:MULTI-ARGUMENT-BOX [DIAGRAM:ARGUMENT 1  :ID 14] [DIAGRAM:ARGUMENT '-  :ID 15] [DIAGRAM:ARGUMENT 2  :ID 16] :ID 17]  :ID 18] [DIAGRAM:ARGUMENT '-  :ID 19] [DIAGRAM:ARGUMENT 3  :ID 20] :ID 21]  :ID 22] :ID 23])
         (old 21)
         (top (d:find-node-by-id tree 17))
         (poo [m [a 1] [a 2] [a 3]])
         (new [m [a 4] [a nil poo] [a nil top] [a '+]]))
    (test tree old new)))

(defun test-3 ()
  (let* ((tree [DIAGRAM:MULTI-ARGUMENT-BOX [DIAGRAM:ARGUMENT 4 [DIAGRAM:MULTI-ARGUMENT-BOX [DIAGRAM:ARGUMENT 'NIL [DIAGRAM:MULTI-ARGUMENT-BOX [DIAGRAM:ARGUMENT 1  :ID 14] [DIAGRAM:ARGUMENT '-  :ID 15] [DIAGRAM:ARGUMENT 2  :ID 16] :ID 17]  :ID 18] [DIAGRAM:ARGUMENT '-  :ID 19] [DIAGRAM:ARGUMENT 3  :ID 20] :ID 21]  :ID 22] :ID 23])
         (old 21)
         (top (d:find-node-by-id tree 17))
         (poo [m [a 1] [a 2] [a nil top]])
         (new [m [a 4] [a nil poo] [a nil] [a '+]]))
    (test tree old new)))
